home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 3_2004-2005.ISO / Data / Zips / Complete_P18201211192004.psc / Model Maker / DrawingMod.bas < prev    next >
BASIC Source File  |  2004-11-19  |  10KB  |  265 lines
  1. Attribute VB_Name = "DrawingMod"
  2. 'Backbuffer
  3. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal HDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  4. Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal HDc As Long) As Long
  5. Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
  6. Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long
  7. Private Declare Function SelectObject Lib "gdi32" (ByVal HDc As Long, ByVal hObject As Long) As Long
  8. Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
  9. Private Declare Function DeleteDC Lib "gdi32" (ByVal HDc As Long) As Long
  10. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  11. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  12. Private Declare Function FillRect Lib "user32" (ByVal HDc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  13. Private Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
  14. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  15.  
  16.  
  17. 'Colors
  18. Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
  19.  
  20. 'Basic
  21. Private Declare Function LineTo Lib "gdi32" (ByVal HDc As Long, ByVal X As Long, ByVal Y As Long) As Long
  22. Private Declare Function MoveToEx Lib "gdi32" (ByVal HDc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpPoint As Long) As Long
  23. Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal HDc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
  24. Public Declare Function SetPixelV Lib "gdi32" (ByVal HDc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
  25. Public Declare Function GetPixel Lib "gdi32" (ByVal HDc As Long, ByVal X As Long, ByVal Y As Long) As Long
  26.  
  27. 'Types
  28.  
  29. Private Type BITMAP
  30.  bmType As Long
  31.  bmWidth As Long
  32.  bmHeight As Long
  33.  bmWidthBytes As Long
  34.  bmPlanes As Long
  35.  bmBitsPixel As Integer
  36.  bmBits As Long
  37. End Type
  38.  
  39. Enum FillMode
  40.  Wireframe = 1
  41.  Solid = 2
  42.  Texture = 3
  43. End Enum
  44.  
  45. Private Type RECT
  46.    Left As Long
  47.    Top As Long
  48.    Right As Long
  49.    Bottom As Long
  50. End Type
  51.  
  52. Private CurrentHdc As Long
  53. Private CurrentBMP As Long
  54. Private OldBMP As Long
  55.  
  56. Private Const PS_SOLID = 0
  57.  
  58. Function CreateHdc(Width As Long, Height As Long) As Long
  59.  Dim lHdcC As Long
  60.   lHdcC = CreateDC("DISPLAY", "", "", ByVal 0&)
  61.   If Not lHdcC = 0 Then
  62.    CurrentHdc = CreateCompatibleDC(lHdcC)
  63.    If Not CurrentHdc = 0 Then
  64.     CurrentBMP = CreateCompatibleBitmap(lHdcC, Width, Height)
  65.     If Not CurrentBMP = 0 Then
  66.      OldBMP = SelectObject(CurrentHdc, CurrentBMP)
  67.      If Not OldBMP = 0 Then
  68.       DeleteDC lHdcC
  69.       CreateHdc = CurrentHdc
  70.       Exit Function
  71.      End If
  72.     End If
  73.    End If
  74.   DeleteDC lHdcC
  75.  End If
  76. End Function
  77.  
  78. Function DeleteHdc(HDc As Long) As Long
  79.  DeleteDC HDc
  80. End Function
  81.  
  82. Function GetCurrentHdc() As Long
  83.  GetCurrentHdc = CurrentHdc
  84. End Function
  85.  
  86. Function DrawHdcOnHdc(SourceHdc As Long, DestinationHdc As Long, Width As Long, Height As Long, xDst As Long, yDst As Long, xSrc As Long, ySrc As Long)
  87.  BitBlt DestinationHdc, xDst, yDst, Width, Height, SourceHdc, xSrc, ySrc, vbSrcCopy
  88. End Function
  89.  
  90. Function ClearHdc(HDc As Long, Width As Long, Heigth As Long)
  91.  Dim hBr As Long
  92.  Dim RectDraw As RECT
  93.  RectDraw.Bottom = 1
  94.  RectDraw.Left = 1
  95.  RectDraw.Right = Width
  96.  RectDraw.Top = Heigth
  97.  hBr = CreateSolidBrush(vbBlack) '&HF0000015 And &H1F& 'GetSysColorBrush(&HF0000015 And &H1F&)
  98.  FillRect HDc, RectDraw, hBr
  99.  DeleteObject hBr
  100. End Function
  101.  
  102. Public Sub DrawCurrentHdc(ByVal HDc As Long, Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0, Optional ByVal WidthSrc As Long = 0, Optional ByVal HeightSrc As Long = 0, Optional ByVal xDst As Long = 0, Optional ByVal yDst As Long = 0)
  103.    If WidthSrc <= 0 Then WidthSrc = 800
  104.    If HeightSrc <= 0 Then HeightSrc = 640
  105.    BitBlt HDc, xDst, yDst, WidthSrc, HeightSrc, GetCurrentHdc(), xSrc, ySrc, vbSrcCopy
  106. End Sub
  107.  
  108. Public Sub Draw( _
  109.       ByVal HDc As Long, Optional SrcHdc, _
  110.       Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0, _
  111.       Optional ByVal WidthSrc As Long = 0, Optional ByVal HeightSrc As Long = 0, _
  112.       Optional ByVal xDst As Long = 0, Optional ByVal yDst As Long = 0 _
  113.    )
  114.    If WidthSrc <= 0 Then WidthSrc = 800
  115.    If HeightSrc <= 0 Then HeightSrc = 640
  116.    If SrcHdc = 0 Then
  117.     BitBlt HDc, xDst, yDst, WidthSrc, HeightSrc, CurrentHdc, xSrc, ySrc, vbSrcCopy
  118.    Else
  119.     BitBlt HDc, xDst, yDst, WidthSrc, HeightSrc, SrcHdc, xSrc, ySrc, vbSrcCopy
  120.    End If
  121. End Sub
  122.  
  123. Public Sub CopyHdc( _
  124.       ByVal HDc As Long, Optional DestHdc As Long, _
  125.       Optional ByVal xSrc As Long = 0, Optional ByVal ySrc As Long = 0, _
  126.       Optional ByVal WidthSrc As Long = 0, Optional ByVal HeightSrc As Long = 0, _
  127.       Optional ByVal xDst As Long = 0, Optional ByVal yDst As Long = 0 _
  128.    )
  129.    If WidthSrc <= 0 Then WidthSrc = 800
  130.    If HeightSrc <= 0 Then HeightSrc = 640
  131.    If DestHdc = 0 Then
  132.     BitBlt CurrentHdc, xDst, yDst, WidthSrc, HeightSrc, HDc, xSrc, ySrc, vbSrcCopy
  133.    Else
  134.     BitBlt DestHdc, xDst, yDst, WidthSrc, HeightSrc, HDc, xSrc, ySrc, vbSrcCopy
  135.    End If
  136. End Sub
  137.  
  138. '
  139.  
  140. Function PrintText(Text As String, X As Long, Y As Long, HDc As Long)
  141.  TextOut HDc, X, Y, Text, Len(Text)
  142. End Function
  143.  
  144. Function DrawLine(X1 As Long, Y1 As Long, X2 As Long, Y2 As Long, HDc As Long)
  145.  MoveToEx HDc, X1, Y1, 0
  146.  LineTo HDc, X2, Y2
  147. End Function
  148.  
  149. Function DrawLineScaled(X1 As Long, Y1 As Long, X2 As Long, Y2 As Long, Scallation As Integer, minx As Integer, MinY As Integer, HDc As Long)
  150.  MoveToEx HDc, (X1 * Scallation) + minx, (Y1 * Scallation) + MinY, 0
  151.  LineTo HDc, (X2 * Scallation) + minx, (Y2 * Scallation) + MinY
  152. End Function
  153.  
  154. Function FillSolidTriangle(Color As Long, FirstVector As Coordinates2D, SecondVector As Coordinates2D, ThirdVector As Coordinates2D, Max As Long, HDc As Long)
  155.  Dim A As Single
  156.  Dim B As Single
  157.  
  158.  Dim N As Long
  159.  Dim M As Long
  160.  
  161.  Dim SmallX As Integer
  162.  Dim BigX As Integer
  163.  Dim SmallY As Integer
  164.  Dim BigY As Integer
  165.  
  166.  SmallX = FirstVector.X
  167.  If SmallX > SecondVector.X Then SmallX = SecondVector.X
  168.  If SmallX > ThirdVector.X Then SmallX = ThirdVector.X
  169.  If SmallX < 0 Then SmallX = 0
  170.  
  171.  SmallY = FirstVector.Y
  172.  If SmallY > SecondVector.Y Then SmallY = SecondVector.Y
  173.  If SmallY > ThirdVector.Y Then SmallY = ThirdVector.Y
  174.  If SmallY < 0 Then SmallY = 0
  175.  
  176.  BigX = FirstVector.X
  177.  If BigX < SecondVector.X Then BigX = SecondVector.X
  178.  If BigX < ThirdVector.X Then BigX = ThirdVector.X
  179.  If BigX > Max Then BigX = Max
  180.  
  181.  BigY = FirstVector.Y
  182.  If BigY < SecondVector.Y Then BigY = SecondVector.Y
  183.  If BigY < ThirdVector.Y Then BigY = ThirdVector.Y
  184.  If BigY > Max Then BigY = Max
  185.   
  186.  Dim GC As Long
  187.  
  188.   
  189.   For A = SmallX To BigX
  190.    For B = SmallY To BigY
  191.     If IsInTriangle2D(Make2DCoordinate(A, B), FirstVector, SecondVector, ThirdVector) = True Then
  192.         SetPixelV HDc, Round(A), Round(B), Color
  193.     End If
  194.    Next
  195.   Next
  196. End Function
  197.  
  198. Function FillTextureTriangle(Texture As ObjectTexture, FirstVector As Coordinates2D, SecondVector As Coordinates2D, ThirdVector As Coordinates2D, Max As Long, HDc As Long) 'Optional UsePerspectiveTexturing As Boolean = False, Optional Triangle3D As ObjectTriangle)
  199.  Dim A As Single
  200.  Dim B As Single
  201.  
  202.  Dim N As Long
  203.  Dim M As Long
  204.  
  205.  Dim SmallX As Integer
  206.  Dim BigX As Integer
  207.  Dim SmallY As Integer
  208.  Dim BigY As Integer
  209.  
  210.  SmallX = FirstVector.X
  211.  If SmallX > SecondVector.X Then SmallX = SecondVector.X
  212.  If SmallX > ThirdVector.X Then SmallX = ThirdVector.X
  213.  If SmallX < 0 Then SmallX = 0
  214.  
  215.  SmallY = FirstVector.Y
  216.  If SmallY > SecondVector.Y Then SmallY = SecondVector.Y
  217.  If SmallY > ThirdVector.Y Then SmallY = ThirdVector.Y
  218.  If SmallY < 0 Then SmallY = 0
  219.  
  220.  BigX = FirstVector.X
  221.  If BigX < SecondVector.X Then BigX = SecondVector.X
  222.  If BigX < ThirdVector.X Then BigX = ThirdVector.X
  223.  If BigX > Max Then BigX = Max
  224.  
  225.  BigY = FirstVector.Y
  226.  If BigY < SecondVector.Y Then BigY = SecondVector.Y
  227.  If BigY < ThirdVector.Y Then BigY = ThirdVector.Y
  228.  If BigY > Max Then BigY = Max
  229.   
  230.  Dim GC As Long
  231.  
  232.   
  233.   For A = SmallX To BigX
  234.    For B = SmallY To BigY
  235.     If IsInTriangle2D(Make2DCoordinate(A, B), FirstVector, SecondVector, ThirdVector) = True Then
  236.      N = Abs((Texture.TextureWidth / (GetXByYInLine(FirstVector.X, FirstVector.Y, SecondVector.X, SecondVector.Y, B) - GetXByYInLine(SecondVector.X, SecondVector.Y, ThirdVector.X, ThirdVector.Y, (B / Texture.TextureWidth)))) * (A / Texture.TextureWidth))
  237.      M = Abs((Texture.TextureHeight / (GetXByYInLine(FirstVector.Y, FirstVector.X, SecondVector.Y, SecondVector.X, A) - GetXByYInLine(SecondVector.Y, SecondVector.X, ThirdVector.Y, ThirdVector.X, (A / Texture.TextureHeight)))) * (B / Texture.TextureHeight))
  238.      
  239.      GC = GetPixel(Texture.TextureHdc, N, M)
  240. '     If GC = 0 Then GC = &HFFFFFF
  241.      
  242. '     SetPixelV Hdc, Round(A), Round(B), GC
  243.     End If
  244.    Next
  245.   Next
  246. End Function
  247.  
  248. Function ChangeForecolor(HDc As Long, Forecolor As Long)
  249.  Dim hPen As Long
  250.  Dim hPenOld As Long
  251.  hPen = CreatePen(PS_SOLID, 1, Forecolor)
  252.  hPenOld = SelectObject(HDc, hPen)
  253. End Function
  254.  
  255. Function DrawGrid(GridsX As Long, Width As Long, GridsY As Long, Height As Long, HDc As Long)
  256.  Dim I As Integer
  257.  For I = 1 To GridsX
  258.   DrawLine (I * (Width / GridsX)), 1, (I * (Width / GridsX)), Height, HDc
  259.  Next
  260.  I = 0
  261.  For I = 1 To GridsX
  262.   DrawLine 1, (I * (Height / GridsY)), Width, (I * (Height / GridsY)), HDc
  263.  Next
  264. End Function
  265.